home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / nt / emacssrc.zip / EMACSSRC.TAR / emacs-19.17 / lisp / cal-french.el < prev    next >
Lisp/Scheme  |  1993-07-23  |  10KB  |  225 lines
  1. ;;; cal-french.el --- calendar functions for the French Revolutionary calendar.
  2.  
  3. ;; Copyright (C) 1988, 1989, 1992 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
  6. ;; Keywords: calendar
  7. ;; Human-Keywords: French Revolutionary calendar, calendar, diary
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  13. ;; accepts responsibility to anyone for the consequences of using it
  14. ;; or for whether it serves any particular purpose or works at all,
  15. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  16. ;; License for full details.
  17.  
  18. ;; Everyone is granted permission to copy, modify and redistribute
  19. ;; GNU Emacs, but only under the conditions described in the
  20. ;; GNU Emacs General Public License.   A copy of this license is
  21. ;; supposed to have been given to you along with GNU Emacs so you
  22. ;; can know your rights and responsibilities.  It should be in a
  23. ;; file named COPYING.  Among other things, the copyright notice
  24. ;; and this notice must be preserved on all copies.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; This collection of functions implements the features of calendar.el and
  29. ;; diary.el that deal with the French Revolutionary calendar.
  30.  
  31. ;; Technical details of the Mayan calendrical calculations can be found in
  32. ;; ``Calendrical Calculations, Part II: Three Historical Calendars''
  33. ;; by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
  34. ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
  35. ;; pages 383-404.
  36.  
  37. ;; Comments, corrections, and improvements should be sent to
  38. ;;  Edward M. Reingold               Department of Computer Science
  39. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  40. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  41. ;;                                   Urbana, Illinois 61801
  42.  
  43. ;;; Code:
  44.  
  45. (require 'calendar)
  46.  
  47. (defconst french-calendar-month-name-array
  48.   ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  49.    "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  50.  
  51. (defconst french-calendar-day-name-array
  52.   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  53.    "Octidi" "Nonidi" "Decadi"])
  54.  
  55. (defconst french-calendar-special-days-array
  56.   ["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Recompense"
  57.    "de la Revolution"])
  58.  
  59. (defun french-calendar-leap-year-p (year)
  60.   "True if YEAR is a leap year on the French Revolutionary calendar.
  61. For Gregorian years 1793 to 1805, the years of actual operation of the
  62. calendar, uses historical practice based on equinoxes is followed (years 3, 7,
  63. and 11 were leap years; 15 and 20 would have been leap years).  For later
  64. years uses the proposed rule of Romme (never adopted)--leap years fall every
  65. four years except century years not divisible 400 and century years that are
  66. multiples of 4000."
  67.   (or (memq year '(3 7 11));; Actual practice--based on equinoxes
  68.       (memq year '(15 20)) ;; Anticipated practice--based on equinoxes
  69.       (and (> year 20)     ;; Romme's proposal--never adopted
  70.            (zerop (% year 4))
  71.            (not (memq (% year 400) '(100 200 300)))
  72.            (not (zerop (% year 4000))))))
  73.  
  74. (defun french-calendar-last-day-of-month (month year)
  75.   "Return last day of MONTH, YEAR on the French Revolutionary calendar.
  76. The 13th month is not really a month, but the 5 (6 in leap years) day period of
  77. `sansculottides' at the end of the year."
  78.   (if (< month 13)
  79.       30
  80.     (if (french-calendar-leap-year-p year)
  81.         6
  82.       5)))
  83.  
  84. (defun calendar-absolute-from-french (date)
  85.   "Compute absolute date from French Revolutionary date DATE.
  86. The absolute date is the number of days elapsed since the (imaginary)
  87. Gregorian date Sunday, December 31, 1 BC."
  88.   (let ((month (extract-calendar-month date))
  89.         (day (extract-calendar-day date))
  90.         (year (extract-calendar-year date)))
  91.     (+ (* 365 (1- year));; Days in prior years
  92.        ;; Leap days in prior years
  93.        (if (< year 20)
  94.            (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
  95.          ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
  96.          (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
  97.             (- (/ (1- year) 100))
  98.             (/ (1- year) 400)
  99.             (- (/ (1- year) 4000))))
  100.        (* 30 (1- month));; Days in prior months this year
  101.        day;; Days so far this month
  102.        654414)));; Days before start of calendar (September 22, 1792).
  103.  
  104. (defun calendar-french-from-absolute (date)
  105.   "Compute the French Revolutionary equivalent for absolute date DATE.
  106. The result is a list of the form (MONTH DAY YEAR).
  107. The absolute date is the number of days elapsed since the
  108. (imaginary) Gregorian date Sunday, December 31, 1 BC."
  109.   (if (< date 654415)
  110.       (list 0 0 0);; pre-French Revolutionary date
  111.     (let* ((approx (/ (- date 654414) 366));; Approximation from below.
  112.            (year                ;; Search forward from the approximation.
  113.             (+ approx
  114.                (calendar-sum y approx
  115.                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
  116.                  1)))
  117.            (month               ;; Search forward from Vendemiaire.
  118.             (1+ (calendar-sum m 1
  119.                   (> date
  120.                      (calendar-absolute-from-french
  121.                       (list m
  122.                             (french-calendar-last-day-of-month m year)
  123.                             year)))
  124.                   1)))
  125.            (day                   ;; Calculate the day by subtraction.
  126.             (- date
  127.                (1- (calendar-absolute-from-french (list month 1 year))))))
  128.     (list month day year))))
  129.  
  130. (defun calendar-print-french-date ()
  131.   "Show the French Revolutionary calendar equivalent of the selected date."
  132.   (interactive)
  133.   (let* ((french-date (calendar-french-from-absolute
  134.                        (calendar-absolute-from-gregorian
  135.                         (or (calendar-cursor-to-date)
  136.                             (error "Cursor is not on a date!")))))
  137.          (y (extract-calendar-year french-date))
  138.          (m (extract-calendar-month french-date))
  139.          (d (extract-calendar-day french-date)))
  140.     (if (< y 1)
  141.         (message "Date is pre-French Revolution")
  142.       (if (= m 13)
  143.           (message "Jour %s de l'Anne'e %d de la Revolution"
  144.                    (aref french-calendar-special-days-array (1- d))
  145.                    y)
  146.         (message "Decade %s, %s de %s de l'Anne'e %d de la Revolution"
  147.                  (make-string (1+ (/ (1- d) 10)) ?I)
  148.                  (aref french-calendar-day-name-array (% (1- d) 10))
  149.                  (aref french-calendar-month-name-array (1- m))
  150.                  y)))))
  151.  
  152. (defun calendar-goto-french-date (date &optional noecho)
  153.   "Move cursor to French Revolutionary date DATE.
  154. Echo French Revolutionary date unless NOECHO is t."
  155.   (interactive
  156.    (let* ((year (calendar-read
  157.                  "Anne'e de la Revolution (>0): "
  158.                  '(lambda (x) (> x 0))
  159.                  (int-to-string
  160.                   (extract-calendar-year
  161.                    (calendar-french-from-absolute
  162.                     (calendar-absolute-from-gregorian
  163.                      (calendar-current-date)))))))
  164.           (month-list
  165.            (mapcar 'list
  166.                    (append french-calendar-month-name-array
  167.                            (if (french-calendar-leap-year-p year)
  168.                                (mapcar
  169.                                 '(lambda (x) (concat "Jour " x))
  170.                                 french-calendar-special-days-array)
  171.                               (cdr;; we don't want rev. day in a non-leap yr.
  172.                                (nreverse
  173.                                 (mapcar
  174.                                  '(lambda (x) (concat "Jour " x))
  175.                                  french-calendar-special-days-array)))))))
  176.           (completion-ignore-case t)
  177.           (month (cdr (assoc
  178.                        (capitalize
  179.                         (completing-read
  180.                          "Mois ou Sansculottide: "
  181.                          month-list
  182.                          nil t))
  183.                        (calendar-make-alist
  184.                         month-list
  185.                         1
  186.                         '(lambda (x) (capitalize (car x)))))))
  187.           (decade (if (> month 12)
  188.                       1
  189.                     (calendar-read
  190.                      "De'cade (1-3): "
  191.                      '(lambda (x) (memq x '(1 2 3))))))
  192.           (day (if (> month 12)
  193.                    (- month 12)
  194.                  (calendar-read
  195.                   "Jour (1-10)): "
  196.                   '(lambda (x) (and (<= 1 x) (<= x 10))))))
  197.           (month (if (> month 12) 13 month))
  198.           (day (+ day (* 10 (1- decade)))))
  199.      (list (list month day year))))
  200.   (calendar-goto-date (calendar-gregorian-from-absolute
  201.                        (calendar-absolute-from-french date)))
  202.   (or noecho (calendar-print-french-date)))
  203.  
  204. (defun diary-french-date ()
  205.   "French calendar equivalent of date diary entry."
  206.   (let* ((french-date (calendar-french-from-absolute
  207.                        (calendar-absolute-from-gregorian date)))
  208.          (y (extract-calendar-year french-date))
  209.          (m (extract-calendar-month french-date))
  210.          (d (extract-calendar-day french-date)))
  211.     (if (> y 0)
  212.       (if (= m 13)
  213.           (format "Jour %s de l'Anne'e %d de la Revolution"
  214.                    (aref french-calendar-special-days-array (1- d))
  215.                    y)
  216.         (format "Decade %s, %s de %s de l'Anne'e %d de la Revolution"
  217.                  (make-string (1+ (/ (1- d) 10)) ?I)
  218.                  (aref french-calendar-day-name-array (% (1- d) 10))
  219.                  (aref french-calendar-month-name-array (1- m))
  220.                  y)))))
  221.  
  222. (provide 'cal-french)
  223.  
  224. ;;; cal-french.el ends here
  225.